home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / block next >
Encoding:
Text File  |  1988-04-03  |  7.2 KB  |  272 lines

  1. \ this file defines the following standard forth words...
  2. \
  3. \ <BLOCK>  (execution vector for BLOCK)
  4. \ R/W      LIST   INDEX   EMPTY-BUFFERS  SAVE-BUFFERS (alias SAVE)
  5. \ FIRST    LIMIT  PREV    .LINE          LOAD
  6. \ THRU
  7. \
  8. \ In addition...several words to open, maintain and close the
  9. \ current SCR-FILE.
  10. \
  11. \ Mike Haas, Delta Research
  12. \ Changed LOAD to set SCR for each screen, then restore if complete.
  13. \ added LOAD-UP.  BTD jan 28 87.
  14. decimal
  15.  
  16. include? FILESIZE? JU:FILEINFO
  17.  
  18. : ?SCROPEN  ( -- quit if no file is open )
  19.   SCR-FILE @ 0=  ?abort" no open SCR-FILE"  ;
  20.  
  21.  
  22. user SCRNAMECNT  60 user# +!  \ 63 byte buffer for open scr-file name
  23. : SCRNAME   ( -- addr )     scrnamecnt 1+  ;
  24. : >SCRNAME  ( addr cnt -- )
  25.   dup >r
  26.   scrname dup >r  dup 63 erase
  27.   swap move
  28.   r> 1- r> swap c!  ;
  29.  
  30. user SCR   user #SCRS-ADDED
  31.  
  32. : #scrs?  ( -- #scrs-in-open-file )  ?SCROPEN
  33.   scrname filesize? 1024 /   #scrs-added @ +  ;
  34.  
  35.    1 constant b/scr
  36.   64 constant C/L
  37.  
  38. : R/W   ( adr BLK# flag -- , flag=0=write )  ?SCROPEN
  39.   >r           ( adr BLK -- )   \ save flag 
  40.   10 shift     ( adr fadr-- )   \ B/BUF *
  41.   SCR-FILE @ -dup
  42.   IF    swap  OFFSET_BEGINNING  fseek? drop  ( adr -- )
  43.         SCR-FILE @  over  1024       ( adr file adr cnt -- )  r
  44.         IF    fread?       ( adr #read-- )  0=
  45.               IF   ( at end of file )
  46.                    dup 1024 bl fill
  47.               THEN
  48.         ELSE  fwrite 0<
  49.               abort" error during screen WRITE"
  50.         THEN  drop
  51.   ELSE  abort" attempted R/W with no open SCR-FILE!"
  52.   THEN  r> drop ;
  53.  
  54. 4 constant #BUF
  55.  
  56. 1024 CONSTANT B/BUF
  57.  
  58. B/BUF  2 CELLS + CONSTANT B/+BUF
  59.  
  60. here (first) !
  61. #BUF B/+BUF * allot
  62. here (limit) !
  63.  
  64. : FIRST  ( --- start-of-bffr-area )   (FIRST) @   ;
  65.  
  66. : LIMIT  ( --- end-of-buffers-area )  (LIMIT) @   ;
  67.  
  68. variable use    first use !
  69.  
  70. variable prev   first prev !
  71.  
  72. : +BUF   ( buf-adr -- next-buf-adr flag )
  73.   B/+BUF  + dup LIMIT < 0=
  74.   IF   drop FIRST
  75.   THEN dup prev @ -   ;
  76.  
  77. : EMPTY-BUFFERS  ( --- )
  78.   FIRST LIMIT OVER  -  erase
  79.   first #buf 0
  80.   DO    $ 7fff,ffff over !  +BUF  drop
  81.   LOOP  drop   ;
  82. empty-buffers
  83.  
  84. : UPDATE           PREV @ @   $ 80000000 OR  PREV @ !  ;
  85.  
  86. : SAVE-BUFFERS ( -- ) 
  87.   ?SCROPEN  LIMIT FIRST
  88.   DO   I @ 0<  IF I CELL+  I @ $ 7FFFFFFF AND DUP >R  0 R/W
  89.                   R> I !   THEN
  90.   B/+BUF +LOOP  ;
  91.  
  92. : SAVE  save-buffers ;
  93.  
  94. : <ASSIGN>  ( BLK#---ADDR )
  95.      USE @ DUP >R
  96.      BEGIN   +BUF   UNTIL
  97.      USE !   R @ 0<
  98.      IF  SAVE-BUFFERS               ( R  CELL+  R @  7FFFFFFF AND  0 R/W )
  99.      THEN
  100.      R !
  101.      R  PREV  !
  102.      R>  CELL+   ;
  103.  
  104. \    <ASSIGN>...
  105. \    1.  RETURNS WITH 1ST ADDR OF BUFF DATA-FIELD
  106. \    2.  SETS PREV TO ADDR OF BUFF BLOCK#-FIELD
  107.  
  108. : NOT-IN-BUFFERS?  ( blk# -- blk# true / addr false )
  109.   true swap  prev @   #buf 0
  110.   DO   ( flag blk prev@ -- )  2dup @  $ 7fff,ffff and -
  111.        IF     +BUF drop
  112.        ELSE   rot drop false -rot  LEAVE
  113.        THEN
  114.   LOOP rot
  115.   IF   drop true
  116.   ELSE swap drop cell+ false
  117.   THEN ;
  118.  
  119. : BUFFER   ( BLK#---ADDR )
  120.   NOT-IN-BUFFERS?
  121.   IF   USE @ DUP >R
  122.        BEGIN   +BUF   UNTIL
  123.        USE !   R @ 0<
  124.        IF   SAVE-BUFFERS          ( R  CELL+  R @  7FFFFFFF AND  0 R/W )
  125.        THEN    R !  R PREV !  R> CELL+
  126.   ELSE DUP CELL- PREV !
  127.   THEN ;
  128.  
  129. \    BUFFER...
  130. \     1.  RETURNS WITH 1ST ADDR OF BUFF DATA-FIELD
  131. \     2.  SETS PREV TO ADDR OF BUFF BLOCK#-FIELD
  132.  
  133. : <BLOCK>  ( BLK#--ADDR )
  134.   NOT-IN-BUFFERS?
  135.   IF  >R
  136.       R <ASSIGN>  DUP CELL- DUP @  ( ADR BUF-ADR BLK# )
  137.       SWAP DUP $ 7FFFFFFF SWAP !     ( ADR BLK# BUF-ADR )
  138.       ROT  R  1   R/W              ( BLK# BUF-ADR )
  139.       DUP >R  ! R>  CELL+          ( ADR )
  140.       R> DROP
  141.   THEN  DUP CELL- PREV !  ;
  142. ' <block> is block
  143.  
  144.  
  145. : LOAD ( scr --- ) ?SCROPEN
  146.   BLK @ >R   SCR @ >R  DUP SCR !   BLK !
  147.   >IN @ >R    0 >IN !
  148.   'TIB @ >r   #TIB @ >r   1024 #TIB !
  149.   INTERPRET
  150.   r> #TIB !   r> 'TIB !
  151.   r> >in !  R> SCR !   r> BLK !      ;
  152.  
  153. : THRU ( from to --- )
  154.   1+ SWAP DO I LOAD LOOP ;
  155.  
  156. : LOAD-UP  ( --- )  SCR @ #SCRS? THRU ;
  157.  
  158. : -->           BLK @ IF   0 >IN !  1 BLK +!
  159.                       THEN   ;   IMMEDIATE
  160.  
  161. : .LINE  ( line# scr# -- )
  162.   block  swap 6 shift +  64 -trailing type  ;
  163.  
  164. : INDEX  ( start end -- )
  165.   ?SCROPEN  #scrs? >r
  166.   over r > 0=
  167.   IF   2dup r 1- min  1+ swap
  168.        DO   cr i 3 .r space
  169.             0 i .line  ?pause
  170.        LOOP
  171.   THEN 2drop cr r> drop  ;
  172.  
  173. : MORE-SCREENS  ( #scrs -- )
  174.   ?SCROPEN  scr-file @
  175.   0 offset_end fseek? drop  ( move to end of file )
  176.   0 1024 allocblock ?dup    ( allocate a 1k area )
  177.   IF   dup MARKFREEBLOCK    ( -- #scrs-needed addr )
  178.        dup 1024 bl fill     ( set it to all 'blanks' )
  179.        swap 0
  180.        DO   scr-file @
  181.             over  1024 fwrite  1024 -
  182.             IF   .err ." error while adding screens!"  QUIT
  183.             THEN 1 #scrs-added +!
  184.        LOOP dup UNMARKFREEBLOCK  FREEBLOCK
  185.   ELSE .err ." can't allocate memory!" quit
  186.   THEN ;
  187.   
  188.        
  189. : SEL   ( scr -- )  ?scropen
  190.   #SCRS?                              ( -- scr #scrs )
  191.   2dup < not                          ( -- scr #scrs flag )
  192.   IF   over >r                        ( save desired scr )
  193.        1- -   \ calcs #needed         ( -- #scrs-needed )
  194.        cr  dup . dup 1 -
  195.        IF   ." screens need"
  196.        ELSE ." screen needs"
  197.        THEN ."  to be added, OK" y/n
  198.        IF   more-screens true
  199.        ELSE drop      false
  200.        THEN r> swap
  201.   ELSE drop true
  202.   THEN
  203.   IF   dup SCR !
  204.   THEN drop ;
  205.   
  206. : LIST  ( scr-- )  DUP SEL SCR @ -   SCREDING @  OR  0=
  207.   IF    CR    ." Scr # " scr @ dup . block
  208.         16 0 DO  CR  I  3 .R  SPACE
  209.                  ( I SCR @ .LINE )  dup 64 -trailing type  64 +
  210.              LOOP  drop CR
  211.   THEN  ;
  212.  
  213. : CLOSE-SCR  ( -- , closes whats in SCR-FILE )
  214.   SCR-FILE @  -dup
  215.   IF   save-buffers  empty-buffers  FCLOSE   scr-file off
  216.        scrnamecnt 64 erase
  217.   THEN ;
  218.  
  219. : <toSCR-FILE>  ( file-pointer -- )
  220.   SCR-FILE !   dos0 1- count 
  221.   63 min >SCRNAME  #scrs-added off  ;
  222.  
  223. : OPEN-SCR  ( -- , eats filename )
  224.   SCR-FILE @
  225.   IF     cr ." SCR-FILE contains another file; close it" y/n  dup
  226.          IF    close-scr
  227.          THEN
  228.   ELSE   true
  229.   THEN   ( -- flag )
  230.   IF     fopen  -dup
  231.          IF   <toSCR-file>
  232.          ELSE cr ." can't find " dos0 1- $type
  233.               ." , create it" y/n
  234.               IF   dos0 new (fopen) -dup
  235.                    IF   fclose  dos0 (fopen)
  236.                         <toSCR-FILE> 2 more-screens
  237.                    ELSE .err ." Can't create screen file" quit
  238.                    THEN
  239.               ELSE quit
  240.               THEN
  241.          THEN
  242.   ELSE   fileword drop
  243.   THEN   ;
  244.  
  245. : \   ( -- , must handle lines with no EOLs in BLOCK mode )
  246.   BLK @  ( interpreting from screens? )
  247.   IF   c/l >IN +!
  248.        >IN @  c/l /  c/l *  >IN !
  249.   ELSE [compile] \
  250.   THEN
  251. ;  immediate
  252.  
  253. : SAVE-FORTH  ( -- , can't save if scr-file is open )
  254.   SCR-FILE @
  255.   ?ABORT" can't SAVE-FORTH with an open SCR-FILE, use CLOSE-SCR."
  256.   SAVE-FORTH  ;
  257.  
  258. : BYE  ( -- , flush the buffers out to the file )
  259.   SCR-FILE @
  260.   IF    save-buffers
  261.   THEN  BYE  ;
  262.  
  263. \ cr cr ."   This file initializes several vectors in the kernal, and may"
  264. \ cr    ." cause problems if it is forgotten."
  265. \ cr    ."   Start over with a fresh image if you need to 'go below' the"
  266. \ cr    ." SCREEN interface, and reload this entire file."
  267. \ cr    ."   We recommend loading this file early, perhaps keeping a 'system'
  268. \ cr    ." on hand with this utility installed, if you need it."
  269. \ cr cr
  270.  
  271. decimal
  272.